home *** CD-ROM | disk | FTP | other *** search
Text File | 1988-06-29 | 87.7 KB | 3,226 lines |
- %========================================================================
- % OPS5 heavily modified by John Fitch to improve efficiency and
- % functionality. This is a Cambridge LISP version.
-
- %%% Compatability for Cambridge LISP
-
- (setsyntax ":=+-*$&?<>" 'break!-character nil)
- (setsyntax ":=+-*$&?<>" 'letter t)
-
- (setq !!excise excise)
- (car!-nil!-legal t)
-
- (dm flatc (n) (list 'length (list 'explode n)))
-
- (dm putprop (x y z) (list 'put x z y)) % Argument order
- (dm !!mapc (x y) (list 'mapc y x)) % Argument order
- (dm !!minus (x) (minus x)) % Possible syntax problem
- (dm prog1 l
- (prog (var)
- (setq var (gensym))
- (return
- `(prog (,var)
- (setq ,var ,(car l))
- ,@(append (cdr l) '((return ,xxx)))))))
-
- (setq !*comp t)
-
- % In general the IO model of Cambridge LISP differs from Franz
- % These functions patch it up a little
-
- (de !!read (prt)
- (prog (x ans)
- (setq x (rds prt))
- (setq ans (read))
- (rds x)
- (return ans)))
-
- (de !!tyipeek (prt)
- (prog (x ans)
- (setq x (rds prt 'input))
- (setq ans (tyipeek))
- (rds x)
- (return ans)))
-
- (de !!princ (x prt)
- (prog (old)
- (setq old (rds prt))
- (princ x)
- (rds old)
- (return x)))
-
- % Useful function not defined in Cambridge LISP
-
- (de delq (a b)
- (cond
- ((null b) nil)
- ((eq a (car b)) (cdr b))
- (t (cons (car b) (delq a (cdr b)))) ))
-
- (fluid
- '(*matrix* *buckets* *accept-file* *write-file* *trace-file*
- *class-list* *brkpts* *strategy* *in-rhs* *ptrace* *wtrace*
- *recording* *refracts* *real-cnt* *virtual-cnt* *max-cs*
- *total-cs* *limit-token* *limit-cs* *critical* *build-trace*
- *wmpart-list* *size-result-array* *result-array*
- *record-array* *result-array* *size-result-array*
- *pcount* *cycle-count* *action-count* *total-token* *max-token*
- *current-token* *total-cs* *max-cs* *total-wm* *max-wm*
- *current-wm* *conflict-set* *wmpart-list* *p-name*
- *remaining-cycles* *first-node* *feature-count* *cur-vars*
- *ce-count* *vars* *ce-vars* *rhs-bound-vars*
- *rhs-bound-ce-vars* *last-branch* *last-node* *subnum*
- *record* *max-record-index* *record-index* *curcond* *sendtocall* *side*
- *flag-part* *data-part* *alpha-flag-part* *alpha-data-part* *wm-filter*
- *wm* *old-wm* *action-type* *data-matched* *last* *variable-memory*
- *filters* *ppline* *halt-flag* *ce-variable-memory* *rest* *max-index*
- *next-index* *break-flag* *phase* *cvec* *cved-least*
- ))
-
-
- % =ALG returns T if A and B are algebraicly equal.
- (de =alg (a b) (zerop (difference a b)))
-
- (de ce-gelm (x k)
- (prog nil
- loop (cond ((eq k 1) (return (car x))))
- (setq k (isub1 k))
- (setq x (cdr x))
- (go loop)))
-
- % The loops in gelm were unwound so that fewer calls on DIFFERENCE
- % would be needed. (JPff comment: Yeak)
- (de gelm (x k)
- (prog (ce sub)
- (setq ce (iquotient k 10000))
- (setq sub (idifference k (itimes ce 10000)))
- celoop(cond ((eq ce 0) (go ph2)))
- (setq x (cdr x))
- (cond ((eq ce 1) (go ph2)))
- (setq x (cdr x))
- (cond ((eq ce 2) (go ph2)))
- (setq x (cdr x))
- (cond ((eq ce 3) (go ph2)))
- (setq x (cdr x))
- (cond ((eq ce 4) (go ph2)))
- (setq ce (idifference ce 4))
- (go celoop)
- ph2 (setq x (car x))
- subloop
- (cond ((eq sub 0) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 1) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 2) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 3) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 4) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 5) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 6) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 7) (go finis)))
- (setq x (cdr x))
- (cond ((eq sub 8) (go finis)))
- (setq sub (idifference sub 8))
- (go subloop)
- finis (return (car x))))
-
-
- %%% Utility functions
-
- (de printline (x)
- (foreach y in x do
- (progn
- (princ " ")
- (print y))))
-
- (de printlinec (x)
- (foreach y in x do
- (progn
- (princ " ")
- (princ y))))
-
- % intersect two lists using eq for the equality test
- (de interq (x y)
- (cond
- ((atom x) nil)
- ((memq (car x) y) (cons (car x) (interq (cdr x) y)))
- (t (interq (cdr x) y))))
-
- (de i-g-v nil
- (prog (x)
- %(sstatus translink t)
- %(setsyntax '{ 66)
- %(setsyntax '} 66)
- %(setsyntax '^ 66)
- (setq *buckets* 64)
- % OPS5 allows 64 named slots
- (setq *accept-file* nil)
- (setq *write-file* nil)
- (setq *trace-file* nil)
- (setq *class-list* nil)
- (setq *brkpts* nil)
- (setq *strategy* 'lex)
- (setq *in-rhs* nil)
- (setq *ptrace* t)
- (setq *wtrace* nil)
- (setq *recording* nil)
- (setq *refracts* nil)
- (setq *real-cnt* (setq *virtual-cnt* 0))
- (setq *max-cs* (setq *total-cs* 0))
- (setq *limit-token* 1000000)
- (setq *limit-cs* 1000000)
- (setq *critical* nil)
- (setq *build-trace* nil)
- (setq *wmpart-list* nil)
- (setq *size-result-array* 127)
- (setq *result-array* (mkvect *size-result-array*))
- (setq *record-array* (mkvect *size-result-array*))
- %%% Used to be 6 "!!!
- (setq x 0)
- loop (putv *result-array* x nil)
- (setq x (iadd1 x))
- (cond ((not (igreaterp x *size-result-array*)) (go loop)))
- (make-bottom-node)
- (setq *pcount* 0)
- (initialize-record)
- (setq *cycle-count* (setq *action-count* 0))
- (setq *total-token*
- (setq *max-token* (setq *current-token* 0)))
- (setq *total-cs* (setq *max-cs* 0))
- (setq *total-wm* (setq *max-wm* (setq *current-wm* 0)))
- (setq *conflict-set* nil)
- (setq *wmpart-list* nil)
- (setq *p-name* nil)
- (setq *remaining-cycles* 1000000)
- (setq *cvec* (mkvect 64))
- (setq *cvec-least* 0)))
-
- % if the size of result-array changes, change the line in i-g-v which
- % sets the value of *size-result-array*
- (de !%warn (what where)
- (prog nil
- (terpri)
- (princ '!?)
- (and *p-name* (princ *p-name*))
- (princ "..")
- (princ where)
- (princ "..")
- (princ what)
- (return where)))
-
- (de !%error (what where)
- (!%warn what where)
- (throw !!error!! '!!error!!))
-
- (de round (x) (fix (plus 0.5 x)))
-
- (de top-levels-eq (la lb)
- (prog nil
- lx (cond
- ((eq la lb) (return t))
- ((null la) (return nil))
- ((null lb) (return nil))
- ((not (eq (car la) (car lb))) (return nil)))
- (setq la (cdr la))
- (setq lb (cdr lb))
- (go lx)))
-
-
- %%% LITERAL and LITERALIZE
-
- (df literal z
- (prog (atm val old)
- top (cond
- ((atom z) (return 'bound))
- ((not (eq (cadr z) '=)) (return (!%warn "wrong format" z))))
- (setq atm (car z))
- (setq val (caddr z))
- (setq z (cdddr z))
- (cond
- ((not (numberp val))
- (!%warn "can bind only to numbers" val))
- ((or (not (idp atm)) (variablep atm))
- (!%warn "can bind only constant atoms" atm))
- ((and
- (setq old (literal-binding-of atm))
- (not (equal old val)))
- (!%warn "attempt to rebind attribute" atm))
- (t (put atm 'ops-bind val)))
- (go top)))
-
- (dm have-compiled-production nil '(not (izerop *pcount*)))
-
- (df literalize l
- (prog (class-name atts)
- (setq class-name (car l))
- (cond
- ((have-compiled-production)
- (!%warn "literalize called after p" class-name)
- (return nil))
- ((get class-name 'att-list)
- (!%warn "attempt to redefine class" class-name)
- (return nil)))
- (setq *class-list* (cons class-name *class-list*))
- (setq atts (remove-duplicates (cdr l)))
- (test-attribute-names atts)
- (mark-conflicts atts atts)
- (put class-name 'att-list atts)))
-
- (df vector-attribute l
- (cond
- ((have-compiled-production)
- (!%warn "vector-attribute called after p" l))
- (t (test-attribute-names l)
- (flag l 'vector-attribute))))
-
- (dm is-vector-attribute (att) `(flagp ,att 'vector-attribute))
-
- (de test-attribute-names (l)
- (!!mapc (function test-attribute-names2) l))
-
- (de test-attribute-names2 (atm)
- (cond
- ((or (not (idp atm)) (variablep atm))
- (!%warn "can bind only constant atoms" atm))))
-
- (de finish-literalize nil
- (cond
- ((not (null *class-list*))
- (!!mapc (function note-user-assigns) *class-list*)
- (!!mapc (function assign-scalars) *class-list*)
- (!!mapc (function assign-vectors) *class-list*)
- (!!mapc (function put-ppdat) *class-list*)
- (!!mapc (function erase-literal-info) *class-list*)
- (setq *class-list* nil)
- (setq *buckets* nil))))
-
- (de put-ppdat (class)
- (prog (al att ppdat)
- (setq ppdat nil)
- (setq al (get class 'att-list))
- top (cond
- ((not (atom al))
- (setq att (car al))
- (setq al (cdr al))
- (setq ppdat
- (cons (cons (literal-binding-of att) att) ppdat))
- (go top)))
- (putprop class ppdat 'ppdat)))
-
-
- % note-user-assigns and note-user-vector-assigns are needed only when
- % literal and literalize are both used in a program. They make sure that
- % the assignments that are made explicitly with literal do not cause problems
- % for the literalized classes.
- (de note-user-assigns (class)
- (!!mapc (function note-user-assigns2) (get class 'att-list)))
-
- (de note-user-assigns2 (att)
- (prog (num conf buck clash)
- (setq num (literal-binding-of att))
- (cond ((null num) (return nil)))
- (setq conf (get att 'conflicts))
- (setq buck (store-binding att num))
- (setq clash (find-common-atom buck conf))
- (and
- clash
- (!%warn
- "attributes in a class assigned the same number"
- (cons att clash)))
- (return nil)))
-
- (de note-user-vector-assigns (att given needed)
- (and
- (greaterp needed given)
- (!%warn
- "vector attribute assigned too small a value in literal"
- att)))
-
- (de assign-scalars (class)
- (!!mapc (function assign-scalars2) (get class 'att-list)))
-
- (de assign-scalars2 (att)
- (prog (tlist num bucket conf)
- (cond
- ((literal-binding-of att) (return nil))
- ((is-vector-attribute att) (return nil)))
- (setq tlist (buckets))
- (setq conf (get att 'conflicts))
- top (cond
- ((atom tlist)
- (!%warn "could not generate a binding" att)
- (store-binding att (!!minus 1))
- (return nil)))
- (setq num (caar tlist))
- (setq bucket (cdar tlist))
- (setq tlist (cdr tlist))
- (cond
- ((disjoint bucket conf) (store-binding att num))
- (t (go top)))) )
-
- (de assign-vectors (class)
- (!!mapc (function assign-vectors2) (get class 'att-list)))
-
- (de assign-vectors2 (att)
- (prog (big conf new old need)
- (cond ((not (is-vector-attribute att)) (return nil)))
- (setq big 1)
- (setq conf (get att 'conflicts))
- top (cond
- ((not (atom conf))
- (setq new (car conf))
- (setq conf (cdr conf))
- (cond
- ((is-vector-attribute new)
- (!%warn
- "class has two vector attributes"
- (list att new)))
- (t (setq big (max (literal-binding-of new) big))))
- (go top)))
- (setq need (iadd1 big))
- (setq old (literal-binding-of att))
- (cond
- (old (note-user-vector-assigns att old need))
- (t (store-binding att need)))
- (return nil)))
-
- (de disjoint (la lb) (not (find-common-atom la lb)))
-
- (de find-common-atom (la lb)
- (prog nil
- top (cond
- ((null la) (return nil))
- ((memq (car la) lb) (return (car la)))
- (t (setq la (cdr la)) (go top)))) )
-
- (de mark-conflicts (rem all)
- (cond
- ((not (null rem))
- (mark-conflicts2 (car rem) all)
- (mark-conflicts (cdr rem) all))))
-
- (de mark-conflicts2 (atm lst)
- (prog (l)
- (setq l lst)
- top (cond ((atom l) (return nil)))
- (conflict atm (car l))
- (setq l (cdr l))
- (go top)))
-
- (de conflict (a b)
- (prog (old)
- (setq old (get a 'conflicts))
- (and
- (not (eq a b))
- (not (memq b old))
- (putprop a (cons b old) 'conflicts))))
-
- (de remove-duplicates (lst)
- (cond
- ((atom lst) nil)
- ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
- (t (cons (car lst) (remove-duplicates (cdr lst)))) ))
-
- (de literal-binding-of (name) (get name 'ops-bind))
-
- (de store-binding (name lit)
- (putprop name lit 'ops-bind)
- (add-bucket name lit))
-
- (de add-bucket (name num)
- (prog (buc)
- (setq buc (assoc num (buckets)))
- (and (not (memq name buc)) (rplacd buc (cons name (cdr buc))))
- (return buc)))
-
- (de buckets nil
- (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
- *buckets*)
-
- (de make-nums (k)
- (prog (nums)
- (setq nums nil)
- l (cond ((ilessp k 2) (return nums)))
- (setq nums (cons (ncons k) nums))
- (setq k (isub1 k))
- (go l)))
-
- (de erase-literal-info (class)
- (!!mapc (function erase-literal-info2) (get class 'att-list))
- (remprop class 'att-list))
-
- (de erase-literal-info2 (att) (remprop att 'conflicts))
-
- %%% LHS Compiler
-
- (df p z
- (finish-literalize)
- (princ '*)
- (compile-production (car z) (cdr z))
- (car z))
-
- (de compile-production (name matrix)
- (prog (erm)
- (setq *p-name* name)
- (setq erm (catch !!error!! (cmp-p name matrix)))
- (setq *p-name* nil)))
-
- (de peek-lex nil (car *matrix*))
-
- (de lex nil
- (prog1 (car *matrix*) (setq *matrix* (cdr *matrix*))))
-
- (de end-of-p nil (atom *matrix*))
-
- (de rest-of-p nil *matrix*)
-
- (de prepare-lex (prod) (setq *matrix* prod))
-
- (de peek-sublex nil (car *curcond*))
-
- (de sublex nil
- (prog1 (car *curcond*) (setq *curcond* (cdr *curcond*))))
-
- (de end-of-ce nil (atom *curcond*))
-
- (de rest-of-ce nil *curcond*)
-
- (de prepare-sublex (ce) (setq *curcond* ce))
-
- (de make-bottom-node nil (setq *first-node* (list '&bus nil)))
-
- (de cmp-p (name matrix)
- (prog (m bakptrs)
- (cond
- ((or (null name) (pairp name))
- (!%error "illegal production name" name))
- ((equal (get name 'production) matrix) (return nil)))
- (prepare-lex matrix)
- (excise-p name)
- (setq bakptrs nil)
- (setq *pcount* (iadd1 *pcount*))
- (setq *feature-count* 0)
- (setq *ce-count* 0)
- (setq *vars* nil)
- (setq *ce-vars* nil)
- (setq *rhs-bound-vars* nil)
- (setq *rhs-bound-ce-vars* nil)
- (setq *last-branch* nil)
- (setq m (rest-of-p))
- l1 (and (end-of-p) (!%error "no '-->' in production" m))
- (cmp-prin)
- (setq bakptrs (cons *last-branch* bakptrs))
- (cond ((not (eq '--> (peek-lex))) (go l1)))
- (lex)
- (check-rhs (rest-of-p))
- (link-new-node
- (list '&p *feature-count* name (encode-dope)
- (encode-ce-dope) (cons 'progn (rest-of-p))))
- (putprop name (cdr (reversewoc bakptrs)) 'backpointers)
- (putprop name matrix 'production)
- (putprop name *last-node* 'topnode)))
-
- (de rating-part (pnode) (cadr pnode))
-
- (de var-part (pnode) (car (cdddr pnode)))
-
- (de ce-var-part (pnode) (cadr (cdddr pnode)))
-
- (de rhs-part (pnode) (caddr (cdddr pnode)))
-
- (de excise-p (name)
- (cond
- ((get name 'topnode)
- (printline (list name 'is 'excised))
- (setq *pcount* (isub1 *pcount*))
- (remove-from-conflict-set name)
- (kill-node (get name 'topnode))
- (remprop name 'production)
- (remprop name 'backpointers)
- (remprop name 'topnode))))
-
- (de kill-node (node)
- (prog nil
- top (cond ((atom node) (return nil)))
- (rplaca node '&old)
- (setq node (cdr node))
- (go top)))
-
- (de cmp-prin nil
- (prog nil
- (setq *last-node* *first-node*)
- (cond
- ((null *last-branch*) (cmp-posce) (cmp-nobeta))
- ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
- (t (cmp-posce) (cmp-and)))) )
-
- (de cmp-negce nil (lex) (cmp-ce))
-
- (de cmp-posce nil
- (setq *ce-count* (iadd1 *ce-count*))
- (cond ((eq (peek-lex) '!{) (cmp-ce+cevar)) (t (cmp-ce))))
-
- (de cmp-ce+cevar nil
- (prog (z)
- (lex)
- (cond
- ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
- (t (cmp-ce) (cmp-cevar)))
- (setq z (lex))
- (or (eq z '!}) (!%error "missing '}" z))))
-
- (de new-subnum (k)
- (or (numberp k) (!%error "tab must be a number" k))
- (setq *subnum* (fix k)))
-
- (de incr-subnum nil (setq *subnum* (iadd1 *subnum*)))
-
- (de cmp-ce nil
- (prog (z)
- (new-subnum 0)
- (setq *cur-vars* nil)
- (setq z (lex))
- (and (atom z) (!%error "atomic conditions are not allowed" z))
- (prepare-sublex z)
- la (cond ((end-of-ce) (return nil)))
- (incr-subnum)
- (cmp-element)
- (go la)))
-
- (de cmp-element nil
- (and (eq (peek-sublex) '!^) (cmp-tab))
- (cond
- ((eq (peek-sublex) '!{) (cmp-product))
- (t (cmp-atomic-or-any))))
-
- (de cmp-atomic-or-any nil
- (cond ((eq (peek-sublex) '<<) (cmp-any)) (t (cmp-atomic))))
-
- (de cmp-any nil
- (prog (a z)
- (sublex)
- (setq z nil)
- la (cond ((end-of-ce) (!%error "missing '>>" a)))
- (setq a (sublex))
- (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
- (link-new-node (list '&any nil (current-field) z))))
-
- (de cmp-tab nil
- (prog (r)
- (sublex)
- (setq r (sublex))
- (setq r ($litbind r))
- (new-subnum r)))
-
- (de $litbind (x)
- (prog (r)
- (cond
- ((and (idp x) (setq r (literal-binding-of x)))
- (return r))
- (t (return x)))) )
-
- (de get-bind (x)
- (prog (r)
- (cond
- ((and (idp x) (setq r (literal-binding-of x)))
- (return r))
- (t (return nil)))) )
-
- (de cmp-atomic nil
- (prog (test x)
- (setq x (peek-sublex))
- (cond
- ((eq x '= ) (setq test 'eq) (sublex))
- ((eq x '<> ) (setq test 'ne) (sublex))
- ((eq x '< ) (setq test 'lt) (sublex))
- ((eq x '<= ) (setq test 'le) (sublex))
- ((eq x '> ) (setq test 'gt) (sublex))
- ((eq x '>= ) (setq test 'ge) (sublex))
- ((eq x '<=>) (setq test 'xx) (sublex))
- (t (setq test 'eq)))
- (cmp-symbol test)))
-
- (de cmp-product nil
- (prog (save)
- (setq save (rest-of-ce))
- (sublex)
- la (cond
- ((end-of-ce)
- (cond
- ((member '!} save)
- (!%error "wrong contex for '}" save))
- (t (!%error "missing '}" save))))
- ((eq (peek-sublex) '!}) (sublex) (return nil)))
- (cmp-atomic-or-any)
- (go la)))
-
- (de variablep (x)
- (cond ((not (idp x)) nil)
- ((flagp x 'nonvariable) nil)
- ((flagp x 'variable) t)
- ((eq (car (explode x)) '<)
- (flag (list x) 'variable)
- t)
- (t (flag (list x) 'nonvariable) nil)))
-
- (de cmp-symbol (test)
- (prog (flag)
- (setq flag t)
- (cond ((eq (peek-sublex) '!/) (sublex) (setq flag nil)))
- (cond
- ((and flag (variablep (peek-sublex))) (cmp-var test))
- ((numberp (peek-sublex)) (cmp-number test))
- ((idp (peek-sublex)) (cmp-constant test))
- (t (!%error "unrecognized symbol" (sublex)))) ))
-
- (de cmp-constant (test)
- (or
- (memq test '(eq ne xx))
- (!%error
- "non-numeric constant after numeric predicate"
- (sublex)))
- (link-new-node
- (list (get test 'ta) nil (current-field) (sublex))))
-
- (de cmp-number (test)
- (link-new-node
- (list (get test 'tn) nil (current-field) (sublex))))
-
- (de current-field nil (field-name *subnum*))
-
- (de field-name (num)
- (cond
- ((igreaterp num 64) (!%error "condition is too long" (rest-of-ce)))
- (t num)))
-
- %%% Compiling variables
- %
- %
- %
- % *cur-vars* are the variables in the condition element currently
- % being compiled. *vars* are the variables in the earlier condition
- % elements. *ce-vars* are the condition element variables. note
- % that the interpreter will not confuse condition element and regular
- % variables even if they have the same name.
- %
- % *cur-vars* is a list of triples: (name predicate subelement-number)
- % eg: ( (<x> eq 3)
- % (<y> ne 1)
- % . . . )
- %
- % *vars* is a list of triples: (name ce-number subelement-number)
- % eg: ( (<x> 3 3)
- % (<y> 1 1)
- % . . . )
- %
- % *ce-vars* is a list of pairs: (name ce-number)
- % eg: ( (ce1 1)
- % (<c3> 3)
- % . . . )
- (de var-dope (var) (atsoc var *vars*))
-
- (de ce-var-dope (var) (atsoc var *ce-vars*))
-
- (de cmp-var (test)
- (prog (old name)
- (setq name (sublex))
- (setq old (atsoc name *cur-vars*))
- (cond
- ((and old (eq (cadr old) 'eq)) (cmp-old-eq-var test old))
- ((and old (eq test 'eq)) (cmp-new-eq-var name old))
- (t (cmp-new-var name test)))) )
-
- (de cmp-new-var (name test)
- (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
-
- (de cmp-old-eq-var (test old)
- (link-new-node
- (list
- (get test 'ts)
- nil
- (current-field)
- (field-name (caddr old)))) )
-
- (de cmp-new-eq-var (name old)
- (prog (pred next)
- (setq *cur-vars* (delq old *cur-vars*))
- (setq next (atsoc name *cur-vars*))
- (cond
- (next (cmp-new-eq-var name next))
- (t (cmp-new-var name 'eq)))
- (setq pred (cadr old))
- (link-new-node
- (list
- (get pred 'ts)
- nil
- (field-name (caddr old))
- (current-field)))) )
-
- (de cmp-cevar nil
- (prog (name old)
- (setq name (lex))
- (setq old (atsoc name *ce-vars*))
- (and
- old
- (!%error "condition element variable used twice" name))
- (setq *ce-vars* (cons (list name 0) *ce-vars*))))
-
- (de cmp-not nil (cmp-beta '¬))
-
- (de cmp-nobeta nil (cmp-beta nil))
-
- (de cmp-and nil (cmp-beta '&and))
-
- (de cmp-beta (kind)
- (prog (tlist vdope vname vpred vpos old)
- (setq tlist nil)
- la (cond ((atom *cur-vars*) (go lb)))
- (setq vdope (car *cur-vars*))
- (setq *cur-vars* (cdr *cur-vars*))
- (setq vname (car vdope))
- (setq vpred (cadr vdope))
- (setq vpos (caddr vdope))
- (setq old (atsoc vname *vars*))
- (cond
- (old (setq tlist (add-test tlist vdope old)))
- ((neq kind '¬) (promote-var vdope)))
- (go la)
- lb (and kind (build-beta kind tlist))
- (or (eq kind '¬) (fudge))
- (setq *last-branch* *last-node*)))
-
- (de add-test (list new old)
- (prog (ttype lloc rloc)
- (setq *feature-count* (iadd1 *feature-count*))
- (setq ttype (get (cadr new) 'tb))
- (setq rloc (encode-singleton (caddr new)))
- (setq lloc (encode-pair (cadr old) (caddr old)))
- (return (cons ttype (cons lloc (cons rloc list)))) ))
-
- % the following two functions encode indices so that gelm can
- % decode them as fast as possible
- (de encode-pair (a b) (iplus (times 10000 (sub1 a)) (isub1 b)))
-
- (de encode-singleton (a) (isub1 a))
-
- (de promote-var (dope)
- (prog (vname vpred vpos new)
- (setq vname (car dope))
- (setq vpred (cadr dope))
- (setq vpos (caddr dope))
- (or
- (eq 'eq vpred)
- (!%error
- "illegal predicate for first occurrence"
- (list vname vpred)))
- (setq new (list vname 0 vpos))
- (setq *vars* (cons new *vars*))))
-
- (de fudge nil
- (!!mapc (function fudge*) *vars*)
- (!!mapc (function fudge*) *ce-vars*))
-
- (de fudge* (z)
- (prog (a)
- (setq a (cdr z))
- (rplaca a (iadd1 (car a)))) )
-
- (de build-beta (type tests)
- (prog (rpred lpred lnode lef)
- (link-new-node (list '&mem nil nil (protomem)))
- (setq rpred *last-node*)
- (cond
- ((eq type '&and)
- (setq lnode (list '&mem nil nil (protomem))))
- (t (setq lnode (list '&two nil nil))))
- (setq lpred (link-to-branch lnode))
- (cond
- ((eq type '&and) (setq lef lpred))
- (t (setq lef (protomem))))
- (link-new-beta-node (list type nil lef rpred tests))))
-
- (de protomem nil (list nil))
-
- (de memory-part (mem-node) (car (cadddr mem-node)))
-
- (de encode-dope nil
- (prog (r all z k)
- (setq r nil)
- (setq all *vars*)
- la (cond ((atom all) (return r)))
- (setq z (car all))
- (setq all (cdr all))
- (setq k (encode-pair (cadr z) (caddr z)))
- (setq r (cons (car z) (cons k r)))
- (go la)))
-
- (de encode-ce-dope nil
- (prog (r all z k)
- (setq r nil)
- (setq all *ce-vars*)
- la (cond ((atom all) (return r)))
- (setq z (car all))
- (setq all (cdr all))
- (setq k (cadr z))
- (setq r (cons (car z) (cons k r)))
- (go la)))
-
- %%% Linking the nodes
-
- (de link-new-node (r)
- (cond
- ((not (member (car r) '(&p &mem &two &and ¬)))
- (setq *feature-count* (iadd1 *feature-count*))))
- (setq *virtual-cnt* (iadd1 *virtual-cnt*))
- (setq *last-node* (link-left *last-node* r)))
-
- (de link-to-branch (r)
- (setq *virtual-cnt* (iadd1 *virtual-cnt*))
- (setq *last-branch* (link-left *last-branch* r)))
-
- (de link-new-beta-node (r)
- (setq *virtual-cnt* (iadd1 *virtual-cnt*))
- (setq *last-node* (link-both *last-branch* *last-node* r))
- (setq *last-branch* *last-node*))
-
- (de link-left (pred succ)
- (prog (a r)
- (setq a (left-outs pred))
- (setq r (find-equiv-node succ a))
- (cond (r (return r)))
- (setq *real-cnt* (iadd1 *real-cnt*))
- (attach-left pred succ)
- (return succ)))
-
- (de link-both (left right succ)
- (prog (a r)
- (setq a (interq (left-outs left) (right-outs right)))
- (setq r (find-equiv-beta-node succ a))
- (cond (r (return r)))
- (setq *real-cnt* (iadd1 *real-cnt*))
- (attach-left left succ)
- (attach-right right succ)
- (return succ)))
-
- (de attach-right (old new)
- (rplaca (cddr old) (cons new (caddr old))))
-
- (de attach-left (old new) (rplaca (cdr old) (cons new (cadr old))))
-
- (de right-outs (node) (caddr node))
-
- (de left-outs (node) (cadr node))
-
- (de find-equiv-node (node list)
- (prog (a)
- (setq a list)
- l1 (cond
- ((atom a) (return nil))
- ((equiv node (car a)) (return (car a))))
- (setq a (cdr a))
- (go l1)))
-
- (de find-equiv-beta-node (node list)
- (prog (a)
- (setq a list)
- l1 (cond
- ((atom a) (return nil))
- ((beta-equiv node (car a)) (return (car a))))
- (setq a (cdr a))
- (go l1)))
-
- % do not look at the predecessor fields of beta nodes; they have to be
- % identical because of the way the candidate nodes were found
- (de equiv (a b)
- (and
- (eq (car a) (car b))
- (or
- (eq (car a) '&mem)
- (eq (car a) '&two)
- (equal (caddr a) (caddr b)))
- (equal (cdddr a) (cdddr b))))
-
- (de beta-equiv (a b)
- (and
- (eq (car a) (car b))
- (equal (cddddr a) (cddddr b))
- (or (eq (car a) '&and) (equal (caddr a) (caddr b)))) )
-
- % the equivalence tests are set up to consider the contents of
- % node memories, so they are ready for the build action
-
-
- %%% Network interpreter
-
- (de match (flag wme)
- (sendto flag (list wme) 'left (list *first-node*)))
-
- % note that eval-nodelist is not set up to handle building
- % productions. would have to add something like ops4's build-flag
- (de eval-nodelist (nl)
- (prog nil
- top (cond ((null nl) (return nil)))
- (setq *sendtocall* nil)
- (setq *last-node* (car nl))
- (apply (caar nl) (cdar nl))
- (setq nl (cdr nl))
- (go top)))
-
- (de sendto (flag data side nl)
- (prog nil
- top (cond ((not nl) (return nil)))
- (setq *side* side)
- (setq *flag-part* flag)
- (setq *data-part* data)
- (setq *sendtocall* t)
- (setq *last-node* (car nl))
- (apply (caar nl) (cdar nl))
- (setq nl (cdr nl))
- (go top)))
-
- % &bus sets up the registers for the one-input nodes.
- % Heavily modified by JPff
-
- (de &bus (outs)
- (prog (dp i)
- (setq i 1)
- (setq *alpha-flag-part* *flag-part*)
- (setq dp (car (setq *alpha-data-part* *data-part*)))
- (while dp
- (progn
- (putv *cvec* i (car dp))
- (setq i (iadd1 i))
- (setq dp (cdr dp))))
- (setq i (isub1 i))
- (cond
- ((ilessp i *cvec-least*)
- (prog (j)
- (setq j (iadd1 i))
- (while (ilessp j *cvec-least*)
- (progn (putv *cvec* j nil)
- (setq j (iadd1 j)))))))
- (setq *cvec-least* i)
- (eval-nodelist outs)))
-
- (de &any (outs register const-list)
- (prog (z c)
- (setq z (getv *cvec* register))
- (cond ((numberp z) (go number)))
- symbol(cond
- ((null const-list) (return nil))
- ((eq (car const-list) z) (go ok))
- (t (setq const-list (cdr const-list)) (go symbol)))
- number(cond
- ((null const-list) (return nil))
- ((and (numberp (setq c (car const-list))) (=alg c z))
- (go ok))
- (t (setq const-list (cdr const-list)) (go number)))
- ok (eval-nodelist outs)))
-
- (de teqa (outs register constant)
- (and (eq (getv *cvec* register) constant) (eval-nodelist outs)))
-
- (put 'eq 'ta 'teqa)
-
- (de tnea (outs register constant)
- (and
- (not (eq (getv *cvec* register) constant))
- (eval-nodelist outs)))
-
- (put 'ne 'ta 'tnea)
-
- (de txxa (outs register constant)
- (and (idp (getv *cvec* register)) (eval-nodelist outs)))
-
- (put 'xx 'ta 'txxa)
-
- (de teqn (outs register constant)
- (prog (z)
- (setq z (getv *cvec* register))
- (and (numberp z) (=alg z constant) (eval-nodelist outs))))
-
- (put 'eq 'tn 'teqn)
-
- (de tnen (outs register constant)
- (prog (z)
- (setq z (getv *cvec* register))
- (and
- (or (not (numberp z)) (not (=alg z constant)))
- (eval-nodelist outs))))
-
- (put 'ne 'tn 'tnen)
-
- (de txxn (outs register constant)
- (and (numberp (getv *cvec* register)) (eval-nodelist outs)))
-
- (put 'xx 'tn 'txxn)
-
- (de tltn (outs register constant)
- (prog (z)
- (setq z (getv *cvec* register))
- (and (numberp z) (greaterp constant z) (eval-nodelist outs))))
-
- (put 'lt 'tn 'tltn)
-
- (de tgtn (outs register constant)
- (prog (z)
- (setq z (getv *cvec* register))
- (and (numberp z) (greaterp z constant) (eval-nodelist outs))))
-
- (put 'gt 'tn 'tgtn)
-
- (de tgen (outs register constant)
- (prog (z)
- (setq z (getv *cvec* register))
- (and
- (numberp z)
- (not (greaterp constant z))
- (eval-nodelist outs))))
-
- (put 'ge 'tn 'tgen)
-
- (de tlen (outs register constant)
- (prog (z)
- (setq z (getv *cvec* register))
- (and
- (numberp z)
- (not (greaterp z constant))
- (eval-nodelist outs))))
-
- (put 'le 'tn 'tlen)
-
- (de teqs (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (cond
- ((eq a b) (eval-nodelist outs))
- ((and (numberp a) (numberp b) (=alg a b))
- (eval-nodelist outs)))) )
-
- (put 'eq 'ts 'teqs)
-
- (de tnes (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (cond
- ((eq a b) (return nil))
- ((and (numberp a) (numberp b) (=alg a b)) (return nil))
- (t (eval-nodelist outs)))) )
-
- (put 'ne 'ts 'tnes)
-
- (de txxs (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (cond
- ((and (numberp a) (numberp b)) (eval-nodelist outs))
- ((and (not (numberp a)) (not (numberp b)))
- (eval-nodelist outs)))) )
-
- (put 'xx 'ts 'txxs)
-
- (de tlts (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (and
- (numberp a)
- (numberp b)
- (greaterp b a)
- (eval-nodelist outs))))
-
- (put 'lt 'ts 'tlts)
-
- (de tgts (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (and
- (numberp a)
- (numberp b)
- (greaterp a b)
- (eval-nodelist outs))))
-
- (put 'gt 'ts 'tgts)
-
- (de tges (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (and
- (numberp a)
- (numberp b)
- (not (greaterp b a))
- (eval-nodelist outs))))
-
- (put 'ge 'ts 'tges)
-
- (de tles (outs vara varb)
- (prog (a b)
- (setq a (getv *cvec* vara))
- (setq b (getv *cvec* varb))
- (and
- (numberp a)
- (numberp b)
- (not (greaterp a b))
- (eval-nodelist outs))))
-
- (put 'le 'ts 'tles)
-
- (de &two (left-outs right-outs)
- (prog (fp dp)
- (cond
- (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
- (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
- (sendto fp dp 'left left-outs)
- (sendto fp dp 'right right-outs)))
-
- (de &mem (left-outs right-outs memory-list)
- (prog (fp dp)
- (cond
- (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
- (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
- (sendto fp dp 'left left-outs)
- (add-token memory-list fp dp nil)
- (sendto fp dp 'right right-outs)))
-
- (de &and (outs lpred rpred tests)
- (prog (mem)
- (cond
- ((eq *side* 'right)
- (cond
- ((not (setq mem (memory-part lpred))) (return nil))
- (t (and-right outs mem tests))))
- ((not (setq mem (memory-part rpred))) (return nil))
- (t (and-left outs mem tests)))))
-
- (de and-left (outs mem tests)
- (prog (fp dp memdp tlist tst lind rind res)
- (setq fp *flag-part*)
- (setq dp *data-part*)
- fail (cond ((null mem) (return nil)))
- (setq memdp (car mem))
- (setq mem (cdr mem))
- (setq tlist tests)
- tloop (cond ((null tlist) (go succ)))
- (setq tst (car tlist))
- (setq tlist (cdr tlist))
- (setq lind (car tlist))
- (setq tlist (cdr tlist))
- (setq rind (car tlist))
- (setq tlist (cdr tlist))
- %% the next line differs in and-left & -right
- (setq res (tst (gelm memdp rind) (gelm dp lind)))
- (cond (res (go tloop)) (t (go fail)))
- succ %% the next line differs in and-left & -right
- (sendto fp (cons (car memdp) dp) 'left outs)
- (go fail)))
-
- (de and-right (outs mem tests)
- (prog (fp dp memdp tlist tst lind rind res)
- (setq fp *flag-part*)
- (setq dp *data-part*)
- fail (cond ((null mem) (return nil)))
- (setq memdp (car mem))
- (setq mem (cdr mem))
- (setq tlist tests)
- tloop (cond ((null tlist) (go succ)))
- (setq tst (car tlist))
- (setq tlist (cdr tlist))
- (setq lind (car tlist))
- (setq tlist (cdr tlist))
- (setq rind (car tlist))
- (setq tlist (cdr tlist))
- %% the next line differs in and-left & -right
- (setq res (tst (gelm dp rind) (gelm memdp lind)))
- (cond (res (go tloop)) (t (go fail)))
- succ %% the next line differs in and-left & -right
- (sendto fp (cons (car dp) memdp) 'right outs)
- (go fail)))
-
- (de teqb (new eqvar)
- (cond
- ((eq new eqvar) t)
- ((not (numberp new)) nil)
- ((not (numberp eqvar)) nil)
- ((=alg new eqvar) t)
- (t nil)))
-
- (put 'eq 'tb 'teqb)
-
- (de tneb (new eqvar)
- (cond
- ((eq new eqvar) nil)
- ((not (numberp new)) t)
- ((not (numberp eqvar)) t)
- ((=alg new eqvar) nil)
- (t t)))
-
- (put 'ne 'tb 'tneb)
-
- (de tltb (new eqvar)
- (cond
- ((not (numberp new)) nil)
- ((not (numberp eqvar)) nil)
- ((greaterp eqvar new) t)
- (t nil)))
-
- (put 'lt 'tb 'tltb)
-
- (de tgtb (new eqvar)
- (cond
- ((not (numberp new)) nil)
- ((not (numberp eqvar)) nil)
- ((greaterp new eqvar) t)
- (t nil)))
-
- (put 'gt 'tb 'tgtb)
-
- (de tgeb (new eqvar)
- (cond
- ((not (numberp new)) nil)
- ((not (numberp eqvar)) nil)
- ((not (greaterp eqvar new)) t)
- (t nil)))
-
- (put 'ge 'tb 'tgeb)
-
- (de tleb (new eqvar)
- (cond
- ((not (numberp new)) nil)
- ((not (numberp eqvar)) nil)
- ((not (greaterp new eqvar)) t)
- (t nil)))
-
- (put 'le 'tb 'tleb)
-
- (de txxb (new eqvar)
- (cond
- ((numberp new) (cond ((numberp eqvar) t) (t nil)))
- (t (cond ((numberp eqvar) nil) (t t)))) )
-
- (put 'xx 'tb 'txxb)
-
- (de &p (rating name var-dope ce-var-dope rhs)
- (prog (fp dp)
- (cond
- (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
- (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
- (and (memq fp '(nil old)) (removecs name dp))
- (and fp (insertcs name dp rating))))
-
- (de &old (a b c d e) nil)
-
- (de ¬ (outs lmem rpred tests)
- (cond
- ((eq *side* 'right)
- (cond ((eq *flag-part* 'old) nil)
- (t (not-right outs (car lmem) tests))))
- (t (not-left outs (memory-part rpred) tests lmem))))
-
- (de not-left (outs mem tests own-mem)
- (prog (fp dp memdp tlist tst lind rind res c)
- (setq fp *flag-part*)
- (setq dp *data-part*)
- (setq c 0)
- fail (cond ((null mem) (go fin)))
- (setq memdp (car mem))
- (setq mem (cdr mem))
- (setq tlist tests)
- tloop (cond ((null tlist) (setq c (iadd1 c)) (go fail)))
- (setq tst (car tlist))
- (setq tlist (cdr tlist))
- (setq lind (car tlist))
- (setq tlist (cdr tlist))
- (setq rind (car tlist))
- (setq tlist (cdr tlist))
- %% the next line differs in not-left & -right
- (setq res (tst (gelm memdp rind) (gelm dp lind)))
- (cond (res (go tloop)) (t (go fail)))
- fin (add-token own-mem fp dp c)
- (cond ((izerop c) (sendto fp dp 'left outs)))))
-
- (de not-right (outs mem tests)
- (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
- (setq fp *flag-part*)
- (setq dp *data-part*)
- (cond
- ((not fp) (setq inc (!!minus 1)) (setq newfp 'new))
- ((eq fp 'new) (setq inc 1) (setq newfp nil))
- (t (return nil)))
- fail (cond ((null mem) (return nil)))
- (setq memdp (car mem))
- (setq newc (cadr mem))
- (setq tlist tests)
- tloop (cond ((null tlist) (go succ)))
- (setq tst (car tlist))
- (setq tlist (cdr tlist))
- (setq lind (car tlist))
- (setq tlist (cdr tlist))
- (setq rind (car tlist))
- (setq tlist (cdr tlist))
- %% the next line differs in not-left & -right
- (setq res (tst (gelm dp rind) (gelm memdp lind)))
- (cond (res (go tloop)) (t (setq mem (cddr mem)) (go fail)))
- succ (setq newc (iplus inc newc))
- (rplaca (cdr mem) newc)
- (cond
- ((or
- (and (eq inc (!!minus 1)) (eq newc 0))
- (and (eq inc 1) (eq newc 1)))
- (sendto newfp memdp 'right outs)))
- (setq mem (cddr mem))
- (go fail)))
-
- %%% Node memories
-
- %(de add-token (memlis flag data-part num)
- % (prog (was-present)
- % (cond
- % ((eq flag 'new)
- % (setq was-present nil)
- % (real-add-token memlis data-part num))
- % ((not flag)
- % (setq was-present (remove-old memlis data-part num)))
- % ((eq flag 'old) (setq was-present t)))
- % (return was-present)))
- (de add-token (memlis flag data-part num)
- (cond
- ((eq flag 'new) (real-add-token memlis data-part num) nil)
- ((not flag) (remove-old memlis data-part num) nil)
- ((eq flag 'old) t)
- (t nil)))
-
- (de real-add-token (lis data-part num)
- (setq *current-token* (iadd1 *current-token*))
- (cond (num (rplaca lis (cons num (car lis)))) )
- (rplaca lis (cons data-part (car lis))))
-
- (de remove-old (lis data num)
- (cond
- (num (remove-old-num lis data))
- (t (remove-old-no-num lis data))))
-
- (de remove-old-num (lis data)
- (prog (m next last)
- (setq m (car lis))
- (cond
- ((atom m) (return nil))
- ((top-levels-eq data (car m))
- (setq *current-token* (isub1 *current-token*))
- (rplaca lis (cddr m))
- (return (car m))))
- (setq next m)
- loop (setq last next)
- (setq next (cddr next))
- (cond
- ((atom next) (return nil))
- ((top-levels-eq data (car next))
- (rplacd (cdr last) (cddr next))
- (setq *current-token* (isub1 *current-token*))
- (return (car next)))
- (t (go loop)))) )
-
- (de remove-old-no-num (lis data)
- (prog (m next last)
- (setq m (car lis))
- (cond
- ((atom m) (return nil))
- ((top-levels-eq data (car m))
- (setq *current-token* (isub1 *current-token*))
- (rplaca lis (cdr m))
- (return (car m))))
- (setq next m)
- loop (setq last next)
- (setq next (cdr next))
- (cond
- ((atom next) (return nil))
- ((top-levels-eq data (car next))
- (rplacd last (cdr next))
- (setq *current-token* (isub1 *current-token*))
- (return (car next)))
- (t (go loop)))) )
-
- %%% Conflict Resolution
- %
- %
- % each conflict set element is a list of the following form:
- % ((p-name . data-part) (sorted wm-recency) special-case-number)
-
- (de removecs (name data)
- (prog (cr-data inst cs)
- (setq cr-data (cons name data))
- (setq cs *conflict-set*)
- l: (cond ((null cs) (record-refract name data) (return nil)))
- (setq inst (car cs))
- (setq cs (cdr cs))
- (cond ((not (top-levels-eq (car inst) cr-data)) (go l:)))
- (setq *conflict-set* (delq inst *conflict-set*))))
-
- (de insertcs (name data rating)
- (prog (instan)
- (cond ((refracted name data) (return nil)))
- (setq instan (list (cons name data) (order-tags data) rating))
- (and (atom *conflict-set*) (setq *conflict-set* nil))
- (return (setq *conflict-set* (cons instan *conflict-set*)))) )
-
- (de order-tags (dat)
- (prog (tags)
- (setq tags nil)
- l1: (cond ((atom dat) (go l2:)))
- (setq tags (cons (creation-time (car dat)) tags))
- (setq dat (cdr dat))
- (go l1:)
- l2: (cond
- ((eq *strategy* 'mea)
- (return (cons (car tags) (dsort (cdr tags)))) )
- (t (return (dsort tags)))) ))
-
- % destructively sort x into descending order
- (de dsort (x)
- (prog (sorted cur next cval nval)
- (cond ((atom (cdr x)) (return x)))
- loop (setq sorted t)
- (setq cur x)
- (setq next (cdr x))
- chek (setq cval (car cur))
- (setq nval (car next))
- (cond
- ((greaterp nval cval)
- (setq sorted nil)
- (rplaca cur nval)
- (rplaca next cval)))
- (setq cur next)
- (setq next (cdr cur))
- (cond
- ((not (null next)) (go chek))
- (sorted (return x))
- (t (go loop)))) )
-
- (de conflict-resolution nil
- (prog (best len)
- (setq len (length *conflict-set*))
- (cond ((igreaterp len *max-cs*) (setq *max-cs* len)))
- (setq *total-cs* (iplus *total-cs* len))
- (cond
- (*conflict-set*
- (setq best (best-of *conflict-set*))
- (setq *conflict-set* (delq best *conflict-set*))
- (return (pname-instantiation best)))
- (t (return nil)))) )
-
- (de best-of (set) (best-of* (car set) (cdr set)))
-
- (de best-of* (best rem)
- (cond
- ((not rem) best)
- ((conflict-set-compare best (car rem))
- (best-of* best (cdr rem)))
- (t (best-of* (car rem) (cdr rem)))) )
-
- (de remove-from-conflict-set (name)
- (prog (cs entry)
- l1 (setq cs *conflict-set*)
- l2 (cond ((atom cs) (return nil)))
- (setq entry (car cs))
- (setq cs (cdr cs))
- (cond
- ((eq name (caar entry))
- (setq *conflict-set* (delq entry *conflict-set*))
- (go l1))
- (t (go l2)))) )
-
- (de pname-instantiation (conflict-elem) (car conflict-elem))
-
- (de order-part (conflict-elem) (cdr conflict-elem))
-
- (de instantiation (conflict-elem)
- (cdr (pname-instantiation conflict-elem)))
-
- (de conflict-set-compare (x y)
- (prog (x-order y-order xl yl xv yv)
- (setq x-order (order-part x))
- (setq y-order (order-part y))
- (setq xl (car x-order))
- (setq yl (car y-order))
- data (cond
- ((and (null xl) (null yl)) (go ps))
- ((null yl) (return t))
- ((null xl) (return nil)))
- (setq xv (car xl))
- (setq yv (car yl))
- (cond
- ((greaterp xv yv) (return t))
- ((greaterp yv xv) (return nil)))
- (setq xl (cdr xl))
- (setq yl (cdr yl))
- (go data)
- ps (setq xl (cdr x-order))
- (setq yl (cdr y-order))
- psl (cond ((null xl) (return t)))
- (setq xv (car xl))
- (setq yv (car yl))
- (cond
- ((greaterp xv yv) (return t))
- ((greaterp yv xv) (return nil)))
- (setq xl (cdr xl))
- (setq yl (cdr yl))
- (go psl)))
-
- (de conflict-set nil
- (prog (cnts cs p z best)
- (setq cnts nil)
- (setq cs *conflict-set*)
- l1: (cond ((atom cs) (go l2:)))
- (setq p (caaar cs))
- (setq cs (cdr cs))
- (setq z (atsoc p cnts))
- (cond
- ((null z) (setq cnts (cons (cons p 1) cnts)))
- (t (rplacd z (iadd1 (cdr z)))) )
- (go l1:)
- l2: (cond
- ((atom cnts)
- (setq best (best-of *conflict-set*))
- (terpri)
- (return (list (caar best) 'dominates))))
- (terpri)
- (princ (caar cnts))
- (cond
- ((greaterp (cdar cnts) 1)
- (princ " (")
- (princ (cdar cnts))
- (princ " occurrences)")))
- (setq cnts (cdr cnts))
- (go l2:)))
-
- %%% WM maintaining functions
- %
- % The order of operations in the following two functions is critical.
- % add-to-wm order: (1) change wm (2) record change (3) match
- % remove-from-wm order: (1) record change (2) match (3) change wm
- % (back will not restore state properly unless wm changes are recorded
- % before the cs changes that they cause) (match will give errors if
- % the thing matched is not in wm at the time)
-
- (de add-to-wm (wme override)
- (prog (fa z part timetag port)
- (setq *critical* t)
- (setq *current-wm* (iadd1 *current-wm*))
- (and
- (greaterp *current-wm* *max-wm*)
- (setq *max-wm* *current-wm*))
- (setq *action-count* (iadd1 *action-count*))
- (setq fa (wm-hash wme))
- (or
- (memq fa *wmpart-list*)
- (setq *wmpart-list* (cons fa *wmpart-list*)))
- (setq part (get fa 'wmpart*))
- (cond
- (override (setq timetag override))
- (t (setq timetag *action-count*)))
- (setq z (cons wme timetag))
- (putprop fa (cons z part) 'wmpart*)
- (record-change '=>wm *action-count* wme)
- (match 'new wme)
- (setq *critical* nil)
- (cond
- ((and *in-rhs* *wtrace*)
- (setq port (trace-file))
- (terpri port)
- (!!princ "=>wm: " port)
- (ppelm wme port)))) )
-
- % remove-from-wm uses eq, not equal to determine if wme is present
- (de remove-from-wm (wme)
- (prog (fa z part timetag port)
- (setq fa (wm-hash wme))
- (setq part (get fa 'wmpart*))
- (setq z (atsoc wme part))
- (cond ((null z) (return nil)))
- (setq timetag (cdr z))
- (cond
- ((and *wtrace* *in-rhs*)
- (setq port (trace-file))
- (terpri port)
- (!!princ "<=wm: " port)
- (ppelm wme port)))
- (setq *action-count* (iadd1 *action-count*))
- (setq *critical* t)
- (setq *current-wm* (sub1 *current-wm*))
- (record-change '<=wm timetag wme)
- (match nil wme)
- (putprop fa (delq z part) 'wmpart*)
- (setq *critical* nil)))
-
- % mapwm maps down the elements of wm, applying fn to each element
- % each element is of form (datum . creation-time)
- (de mapwm (fn)
- (prog (wmpl part)
- (setq wmpl *wmpart-list*)
- lab1 (cond ((atom wmpl) (return nil)))
- (setq part (get (car wmpl) 'wmpart*))
- (setq wmpl (cdr wmpl))
- (!!mapc fn part)
- (go lab1)))
-
- (df wm a
- (!!mapc (function (lambda (z) (terpri) (ppelm z nil))) (get-wm a))
- nil)
-
- (de get-wm (z)
- (setq *wm-filter* z)
- (setq *wm* nil)
- (mapwm (function get-wm2))
- (prog1 *wm* (setq *wm* nil)))
-
- (de get-wm2 (elem)
- (cond
- ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
- (setq *wm* (cons (car elem) *wm*)))) )
-
- (de wm-hash (x)
- (cond
- ((not x) '<default>)
- ((not (car x)) (wm-hash (cdr x)))
- ((idp (car x)) (car x))
- (t (wm-hash (cdr x)))) )
-
- (de creation-time (wme)
- (cdr (atsoc wme (get (wm-hash wme) 'wmpart*))))
-
- (de refresh nil
- (prog nil
- (setq *old-wm* nil)
- (mapwm (function refresh-collect))
- (!!mapc (function refresh-del) *old-wm*)
- (!!mapc (function refresh-add) *old-wm*)
- (setq *old-wm* nil)))
-
- (de refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
-
- (de refresh-del (x) (remove-from-wm (car x)))
-
- (de refresh-add (x) (add-to-wm (car x) (cdr x)))
-
- (de trace-file ()
- (prog (port)
- (setq port nil)
- (cond
- (*trace-file*
- (setq port ($ofile *trace-file*))
- (cond
- ((null port)
- (!%warn "trace: file has been closed" *trace-file*)
- (setq port nil)))) )
- (return port)))
-
- %%% Basic functions for RHS evaluation
-
- (de eval-rhs (pname data)
- (prog (node port)
- (cond
- (*ptrace*
- (setq port (trace-file))
- (terpri port)
- (!!princ *cycle-count* port)
- (!!princ ". " port)
- (!!princ pname port)
- (time-tag-print data port)))
- (setq *data-matched* data)
- (setq *p-name* pname)
- (setq *last* nil)
- (setq node (get pname 'topnode))
- (init-var-mem (var-part node))
- (init-ce-var-mem (ce-var-part node))
- (begin-record pname data)
- (setq *in-rhs* t)
- (eval (rhs-part node))
- (setq *in-rhs* nil)
- (end-record)))
-
- (de time-tag-print (data port)
- (cond
- ((not (null data))
- (time-tag-print (cdr data) port)
- (!!princ " " port)
- (!!princ (creation-time (car data)) port))))
-
- (de init-var-mem (vlist)
- (prog (v ind r)
- (setq *variable-memory* nil)
- top (cond ((atom vlist) (return nil)))
- (setq v (car vlist))
- (setq ind (cadr vlist))
- (setq vlist (cddr vlist))
- (setq r (gelm *data-matched* ind))
- (setq *variable-memory* (cons (cons v r) *variable-memory*))
- (go top)))
-
- (de init-ce-var-mem (vlist)
- (prog (v ind r)
- (setq *ce-variable-memory* nil)
- top (cond ((atom vlist) (return nil)))
- (setq v (car vlist))
- (setq ind (cadr vlist))
- (setq vlist (cddr vlist))
- (setq r (ce-gelm *data-matched* ind))
- (setq *ce-variable-memory*
- (cons (cons v r) *ce-variable-memory*))
- (go top)))
-
- (de make-ce-var-bind (var elem)
- (setq *ce-variable-memory*
- (cons (cons var elem) *ce-variable-memory*)))
-
- (de make-var-bind (var elem)
- (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
-
- (de $varbind (x)
- (prog (r)
- (cond ((not *in-rhs*) (return x)))
- (setq r (atsoc x *variable-memory*))
- (cond (r (return (cdr r))) (t (return x)))) )
-
- (de get-ce-var-bind (x)
- (prog (r)
- (cond ((numberp x) (return (get-num-ce x))))
- (setq r (atsoc x *ce-variable-memory*))
- (cond (r (return (cdr r))) (t (return nil)))) )
-
- (de get-num-ce (x)
- (prog (r l d)
- (setq r *data-matched*)
- (setq l (length r))
- (setq d (difference l x))
- (cond ((greaterp 0 d) (return nil)))
- la (cond
- ((null r) (return nil))
- ((greaterp 1 d) (return (car r))))
- (setq d (sub1 d))
- (setq r (cdr r))
- (go la)))
-
- (de build-collect (z)
- (prog (r)
- la (cond ((atom z) (return nil)))
- (setq r (car z))
- (setq z (cdr z))
- (cond
- ((pairp r) ($value '!() (build-collect r) ($value '!) ))
- ((eq r '!!) ($change (car z)) (setq z (cdr z)))
- (t ($value r)))
- (go la)))
-
- (de unflat (x) (setq *rest* x) (unflat*))
-
- (de unflat* nil
- (prog (c)
- (cond ((atom *rest*) (return nil)))
- (setq c (car *rest*))
- (setq *rest* (cdr *rest*))
- (cond
- ((eq c '!() (return (cons (unflat*) (unflat*))))
- ((eq c '!)) (return nil))
- (t (return (cons c (unflat*)))) )))
-
- (de $change (x)
- (prog nil
- (cond
- ((pairp x) (eval-function x))
- (t ($value ($varbind x)))) ))
-
- (de eval-args (z)
- (prog (r)
- (rhs-tab 1)
- la (cond ((atom z) (return nil)))
- (setq r (car z))
- (setq z (cdr z))
- (cond
- ((eq r '!^)
- (rhs-tab (car z))
- (setq r (cadr z))
- (setq z (cddr z))))
- (cond
- ((eq r '!/) ($value (car z)) (setq z (cdr z)))
- (t ($change r)))
- (go la)))
-
- (de eval-function (form)
- (cond
- ((not *in-rhs*)
- (!%warn "functions cannot be used at top level" (car form)))
- (t (eval form))))
-
-
- %%% Functions to manipulate the result array
-
- (de $reset nil (setq *max-index* 0) (setq *next-index* 1))
-
- % rhs-tab implements the tab ('^') function in the rhs. it has
- % four responsibilities:
- % - to move the array pointers
- % - to watch for tabbing off the left end of the array
- % (ie, to watch for pointers less than 1)
- % - to watch for tabbing off the right end of the array
- % - to write nil in all the slots that are skipped
- % the last is necessary if the result array is not to be cleared
- % after each use% if rhs-tab did not do this, $reset
- % would be much slower.
-
- (de rhs-tab (z) ($tab ($varbind z)))
-
- (de $tab (z)
- (prog (edge next)
- (setq next ($litbind z))
- (and (floatp next) (setq next (fix next)))
- (cond
- ((or
- (not (numberp next))
- (greaterp next *size-result-array*)
- (greaterp 1 next))
- (!%warn "illegal index after ^" next)
- (return *next-index*)))
- (setq edge (isub1 next))
- (cond ((greaterp *max-index* edge) (go ok)))
- clear (cond ((eq *max-index* edge) (go ok)))
- (putv *result-array* edge nil)
- (setq edge (isub1 edge))
- (go clear)
- ok (setq *next-index* next)
- (return next)))
-
- (de $value (v)
- (cond
- ((greaterp *next-index* *size-result-array*)
- (!%warn "index too large" *next-index*))
- (t (and
- (greaterp *next-index* *max-index*)
- (setq *max-index* *next-index*))
- (putv *result-array* *next-index* v)
- (setq *next-index* (iadd1 *next-index*)))) )
-
- (de use-result-array nil
- (prog (k r)
- (setq k *max-index*)
- (setq r nil)
- top (cond ((eq k 0) (return r)))
- (setq r (cons (getv *result-array* k) r))
- (setq k (isub1 k))
- (go top)))
-
- (de $assert nil
- (setq *last* (use-result-array))
- (add-to-wm *last* nil))
-
- (de $parametercount nil *max-index*)
-
- (de $parameter (k)
- (cond
- ((or
- (not (numberp k))
- (igreaterp k *size-result-array*)
- (ilessp k 1))
- (!%warn "illegal parameter number " k)
- nil)
- ((igreaterp k *max-index*) nil)
- (t (getv *result-array* k))))
-
- %%% RHS actions
-
- (df make z
- (prog nil
- ($reset)
- (eval-args z)
- ($assert)))
-
- (df modify z
- (prog (old)
- (cond
- ((not *in-rhs*)
- (!%warn "cannot be called at top level" 'modify)
- (return nil)))
- (setq old (get-ce-var-bind (car z)))
- (cond
- ((null old)
- (!%warn
- "modify: first argument must be an element variable"
- (car z))
- (return nil)))
- (remove-from-wm old)
- (setq z (cdr z))
- ($reset)
- copy (cond ((atom old) (go fin)))
- ($change (car old))
- (setq old (cdr old))
- (go copy)
- fin (eval-args z)
- ($assert)))
-
- (df bind z
- (prog (val)
- (cond
- ((not *in-rhs*)
- (!%warn "cannot be called at top level" 'bind)
- (return nil)))
- (cond
- ((ilessp (length z) 1)
- (!%warn "bind: wrong number of arguments to" z)
- (return nil))
- ((not (idp (car z)))
- (!%warn "bind: illegal argument" (car z))
- (return nil))
- ((eq (length z) 1) (setq val (gensym)))
- (t ($reset) (eval-args (cdr z)) (setq val ($parameter 1))))
- (make-var-bind (car z) val)))
-
- (df cbind z
- (cond
- ((not *in-rhs*)
- (!%warn "cannot be called at top level" 'cbind))
- ((not (eq (length z) 1))
- (!%warn "cbind: wrong number of arguments" z))
- ((not (idp (car z)))
- (!%warn "cbind: illegal argument" (car z)))
- ((null *last*) (!%warn "cbind: nothing added yet" (car z)))
- (t (make-ce-var-bind (car z) *last*))))
-
- (df remove z
- (prog (old)
- (cond ((not *in-rhs*) (return (top-level-remove z))))
- top (cond ((atom z) (return nil)))
- (setq old (get-ce-var-bind (car z)))
- (cond
- ((null old)
- (!%warn
- "remove: argument not an element variable"
- (car z))
- (return nil)))
- (remove-from-wm old)
- (setq z (cdr z))
- (go top)))
-
- (df call z
- (prog (f)
- (setq f (car z))
- ($reset)
- (eval-args (cdr z))
- (f)))
-
- (df write z
- (prog (port max k x needspace)
- (cond
- ((not *in-rhs*)
- (!%warn "cannot be called at top level" 'write)
- (return nil)))
- ($reset)
- (eval-args z)
- (setq k 1)
- (setq max ($parametercount))
- (cond
- ((ilessp max 1)
- (!%warn "write: nothing to print" z)
- (return nil)))
- (setq port (default-write-file))
- (setq x ($parameter 1))
- (cond
- ((and (idp x) ($ofile x))
- (setq port ($ofile x))
- (setq k 2)))
- (setq needspace t)
- la (cond ((greaterp k max) (return nil)))
- (setq x ($parameter k))
- (cond
- ((eq x "=== C R L F ===")
- (setq needspace nil)
- (terpri port))
- ((eq x "=== R J U S T ===")
- (setq k (iplus 2 k))
- (do-rjust ($parameter (isub1 k)) ($parameter k) port))
- ((eq x "=== T A B T O ===")
- (setq needspace nil)
- (setq k (iadd1 k))
- (do-tabto ($parameter k) port))
- (t (and needspace (!!princ " " port))
- (setq needspace t)
- (!!princ x port)))
- (setq k (iadd1 k))
- (go la)))
-
- (de default-write-file ()
- (prog (port)
- (setq port nil)
- (cond
- (*write-file*
- (setq port ($ofile *write-file*))
- (cond
- ((null port)
- (!%warn "write: file has been closed" *write-file*)
- (setq port nil)))) )
- (return port)))
-
- (de do-rjust (width value port k)
- (prog (size)
- (cond
- ((eq value "=== T A B T O ===")
- (!%warn "rjust cannot precede this function" 'tabto)
- (return nil))
- ((eq value "=== C R L F ===")
- (!%warn "rjust cannot precede this function" 'crlf)
- (return nil))
- ((eq value "=== R J U S T ===")
- (!%warn "rjust cannot precede this function" 'rjust)
- (return nil)))
- (setq size (flatc value (iadd1 width)))
- (cond
- ((greaterp size width)
- (!!princ " " port)
- (!!princ value port)
- (return nil)))
- (setq k (difference width size))
- (while (greaterp k 0)
- (progn (setq k (isub1 k))
- (!!princ " " port)))
- (!!princ value port)))
-
- (de do-tabto (col port)
- (prog (pos k)
- (setq pos (iadd1 (posn port)))
- (cond ((greaterp pos col) (terpri port) (setq pos 1)))
- (setq k (difference col pos))
- (while (greaterp k 0)
- (progn (setq k (isub1 k))
- (!!princ " " port)))
- (return nil)))
-
- (de halt nil
- (cond
- ((not *in-rhs*) (!%warn "cannot be called at top level" 'halt))
- (t (setq *halt-flag* t))))
-
- (de build z
- (prog (r)
- (cond
- ((not *in-rhs*)
- (!%warn "cannot be called at top level" 'build)
- (return nil)))
- ($reset)
- (build-collect z)
- (setq r (unflat (use-result-array)))
- (and *build-trace* (*build-trace* r))
- (compile-production (car r) (cdr r))))
-
- (df openfile z
- (prog (file mode id)
- ($reset)
- (eval-args z)
- (cond
- ((not (eq ($parametercount) 3))
- (!%warn "openfile: wrong number of arguments" z)
- (return nil)))
- (setq id ($parameter 1))
- (setq file ($parameter 2))
- (setq mode ($parameter 3))
- (cond
- ((not (idp id))
- (!%warn "openfile: file id must be a symbolic atom" id)
- (return nil))
- ((null id)
- (!%warn
- "openfile: 'nil' is reserved for the terminal"
- nil)
- (return nil))
- ((or ($ifile id) ($ofile id))
- (!%warn "openfile: name already in use" id)
- (return nil)))
- (cond
- ((eq mode 'in) (putprop id (open file 'input) 'inputfile))
- ((eq mode 'out) (putprop id (open file 'output) 'outputfile))
- (t (!%warn "openfile: illegal mode" mode) (return nil)))
- (return nil)))
-
- (de $ifile (x) (get x 'inputfile))
-
- (de $ofile (x) (get x 'outputfile))
-
- (df closefile z
- ($reset)
- (eval-args z)
- (!!mapc (function closefile2) (use-result-array)))
-
- (de closefile2 (file)
- (prog (port)
- (cond
- ((not (idp file))
- (!%warn "closefile: illegal file identifier" file))
- ((setq port ($ifile file))
- (close port)
- (remprop file 'inputfile))
- ((setq port ($ofile file))
- (close port)
- (remprop file 'outputfile)))
- (return nil)))
-
- (df default z
- (prog (file use)
- ($reset)
- (eval-args z)
- (cond
- ((not (eq ($parametercount) 2))
- (!%warn "default: wrong number of arguments" z)
- (return nil)))
- (setq file ($parameter 1))
- (setq use ($parameter 2))
- (cond
- ((not (idp file))
- (!%warn "default: illegal file identifier" file)
- (return nil))
- ((not (memq use '(write accept trace)))
- (!%warn "default: illegal use for a file" use)
- (return nil))
- ((and
- (memq use '(write trace))
- (not (null file))
- (not ($ofile file)))
- (!%warn
- "default: file has not been opened for output"
- file)
- (return nil))
- ((and
- (eq use 'accept)
- (not (null file))
- (not ($ifile file)))
- (!%warn
- "default: file has not been opened for input"
- file)
- (return nil))
- ((eq use 'write) (setq *write-file* file))
- ((eq use 'accept) (setq *accept-file* file))
- ((eq use 'trace) (setq *trace-file* file)))
- (return nil)))
-
-
- %%% RHS Functions
-
- (df accept z
- (prog (port arg)
- (cond
- ((igreaterp (length z) 1)
- (!%warn "accept: wrong number of arguments" z)
- (return nil)))
- (setq port nil)
- (cond
- (*accept-file*
- (setq port ($ifile *accept-file*))
- (cond
- ((null port)
- (!%warn
- "accept: file has been closed"
- *accept-file*)
- (return nil)))) )
- (cond
- ((eq (length z) 1)
- (setq arg ($varbind (car z)))
- (cond
- ((not (idp arg))
- (!%warn "accept: illegal file name" arg)
- (return nil)))
- (setq port ($ifile arg))
- (cond
- ((null port)
- (!%warn "accept: file not open for input" arg)
- (return nil)))) )
- (cond
- ((eq (!!tyipeek port) (!!minus 1))
- ($value 'end-of-file)
- (return nil)))
- (flat-value (!!read port))))
-
- (de flat-value (x)
- (cond ((atom x) ($value x)) (t (!!mapc (function flat-value) x))))
-
- (de span-chars (x prt)
- (prog (ch)
- (setq ch (!!tyipeek prt))
- (while (member ch x)
- (progn (!!readc prt) (setq ch (!!tyipeek prt))))))
-
- (df acceptline z
- (prog (c def arg port)
- (setq port nil)
- (setq def z)
- (cond
- (*accept-file*
- (setq port ($ifile *accept-file*))
- (cond
- ((null port)
- (!%warn
- "acceptline: file has been closed"
- *accept-file*)
- (return nil)))) )
- (cond
- ((pairp def) %% replaces the awful (greaterp (length def) 0)
- (setq arg ($varbind (car def)))
- (cond
- ((and (idp arg) ($ifile arg))
- (setq port ($ifile arg))
- (setq def (cdr def)))) ))
- (span-chars '(9 41) port)
- (setq c (tyi port))
- (cond
- ((memq (!!tyipeek port) '(-1 10))
- (!!mapc (function $change) def)
- (return nil)))
- l: (flat-value (!!read port))
- (span-chars '(9 41) port)
- (cond
- ((not (memq (!!tyipeek port) '(difference1 10)))
- (go l:)))) )
-
- (df substr l
- (prog (k elm start end)
- (cond
- ((not (eq (length l) 3))
- (!%warn "substr: wrong number of arguments" l)
- (return nil)))
- (setq elm (get-ce-var-bind (car l)))
- (cond
- ((null elm)
- (!%warn "first argument to substr must be a ce var" l)
- (return nil)))
- (setq start ($varbind (cadr l)))
- (setq start ($litbind start))
- (cond
- ((not (numberp start))
- (!%warn "second argument to substr must be a number" l)
- (return nil)))
- %% if a variable is bound to INF, the following
- %% will get the binding and treat it as INF is
- %% always treated. That may not be good.
- (setq end ($varbind (caddr l)))
- (cond ((eq end 'inf) (setq end (length elm))))
- (setq end ($litbind end))
- (cond
- ((not (numberp end))
- (!%warn "third argument to substr must be a number" l)
- (return nil)))
- %% this loop does not check for the end of elm
- %% instead it relies on cdr of nil being nil
- %% this may not work in all versions of lisp
- (setq k 1)
- la (cond
- ((igreaterp k end) (return nil))
- ((not (ilessp k start)) ($value (car elm))))
- (setq elm (cdr elm))
- (setq k (iadd1 k))
- (go la)))
-
- (df compute z ($value (ari z)))
-
- % arith is the obsolete form of compute
- (df arith z ($value (ari z)))
-
- (de ari (x)
- (cond
- ((atom x) (!%warn "bad syntax in arithmetic expression " x) 0)
- ((atom (cdr x)) (ari-unit (car x)))
- ((eq (cadr x) '+) (plus (ari-unit (car x)) (ari (cddr x))))
- ((eq (cadr x) '-)
- (difference (ari-unit (car x)) (ari (cddr x))))
- ((eq (cadr x) '*) (times (ari-unit (car x)) (ari (cddr x))))
- ((eq (cadr x) '!/)
- (quotient (ari-unit (car x)) (ari (cddr x))))
- ((eq (cadr x) '!!)
- (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))) )
- (t (!%warn "bad syntax in arithmetic expression " x) 0)))
-
- (de ari-unit (a)
- (prog (r)
- (cond ((pairp a) (setq r (ari a))) (t (setq r ($varbind a))))
- (cond
- ((not (numberp r))
- (!%warn "bad value in arithmetic expression" a)
- (return 0))
- (t (return r)))) )
-
- (de genatom nil ($value (gensym)))
-
- (df litval z
- (prog (r)
- (cond
- ((not (eq (length z) 1))
- (!%warn "litval: wrong number of arguments" z)
- ($value 0)
- (return nil))
- ((numberp (car z)) ($value (car z)) (return nil)))
- (setq r ($litbind ($varbind (car z))))
- (cond ((numberp r) ($value r) (return nil)))
- (!%warn "litval: argument has no literal binding" (car z))
- ($value 0)))
-
- (df rjust z
- (prog (val)
- (cond
- ((not (eq (length z) 1))
- (!%warn "rjust: wrong number of arguments" z)
- (return nil)))
- (setq val ($varbind (car z)))
- (cond
- ((or (not (numberp val)) (ilessp val 1) (igreaterp val 127))
- (!%warn "rjust: illegal value for field width" val)
- (return nil)))
- ($value "=== R J U S T ===")
- ($value val)))
-
- (df crlf z
- (cond
- (z (!%warn "crlf: does not take arguments" z))
- (t ($value "=== C R L F ==="))))
-
- (df tabto z
- (prog (val)
- (cond
- ((not (eq (length z) 1))
- (!%warn "tabto: wrong number of arguments" z)
- (return nil)))
- (setq val ($varbind (car z)))
- (cond
- ((or (not (numberp val)) (ilessp val 1) (igreaterp val 127))
- (!%warn "tabto: illegal column number" z)
- (return nil)))
- ($value "=== T A B T O ===")
- ($value val)))
-
- %%% Printing WM
-
- (df ppwm avlist
- (prog (next a)
- (setq *filters* nil)
- (setq next 1)
- l: (cond ((atom avlist) (go print)))
- (setq a (car avlist))
- (setq avlist (cdr avlist))
- (cond
- ((eq a '!^)
- (setq next (car avlist))
- (setq avlist (cdr avlist))
- (setq next ($litbind next))
- (and (floatp next) (setq next (fix next)))
- (cond
- ((or
- (not (numberp next))
- (igreaterp next *size-result-array*)
- (igreaterp 1 next))
- (!%warn "illegal index after ^" next)
- (return nil))))
- ((variablep a)
- (!%warn "ppwm does not take variables" a)
- (return nil))
- (t (setq *filters* (cons next (cons a *filters*)))
- (setq next (iadd1 next))))
- (go l:)
- print (mapwm (function ppwm2))
- (terpri)
- (return nil)))
-
- (de ppwm2 (elm-tag)
- (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) nil))))
-
- (de filter (elm)
- (prog (fl indx val)
- (setq fl *filters*)
- top (cond ((atom fl) (return t)))
- (setq indx (car fl))
- (setq val (cadr fl))
- (setq fl (cddr fl))
- (cond ((ident (nth (isub1 indx) elm) val) (go top)))
- (return nil)))
-
- (de ident (x y)
- (cond
- ((eq x y) t)
- ((not (numberp x)) nil)
- ((not (numberp y)) nil)
- ((=alg x y) t)
- (t nil)))
-
- % the new ppelm is designed especially to handle literalize format
- % however, it will do as well as the old ppelm on other formats
- (de ppelm (elm port)
- (prog (ppdat sep val att mode lastpos curpos vlist)
- (!!princ (creation-time elm) port)
- (!!princ ": " port)
- (setq mode 'vector)
- (setq ppdat (get (car elm) 'ppdat))
- (and ppdat (setq mode 'a-v))
- (setq sep "(")
- (setq lastpos 0)
- (setq curpos 1) (setq vlist elm)
- (while (not (atom vlist))
- (progn
- (setq val (car vlist))
- (setq att (assoc curpos ppdat))
- (cond (att (setq att (cdr att))) (t (setq att curpos)))
- (and
- (idp att)
- (is-vector-attribute att)
- (setq mode 'vector))
- (cond
- ((or (not (null val)) (eq mode 'vector))
- (!!princ sep port)
- (ppval val att lastpos port)
- (setq sep " ")
- (setq lastpos curpos)))
- (setq curpos (iadd1 curpos))
- (setq vlist (cdr vlist))))
- (!!princ ")" port)))
-
- (de ppval (val att lastpos port)
- (cond
- ((not (eq att (iadd1 lastpos)))
- (!!princ '!^ port)
- (!!princ att port)
- (!!princ " " port)))
- (!!princ val port))
-
- %%% printing production memory
-
- (df pm z (!!mapc (function pprule) z) (terpri) nil)
-
- (de pprule (name)
- (prog (matrix next lab)
- (cond ((not (idp name)) (return nil)))
- (setq matrix (get name 'production))
- (cond ((null matrix) (return nil)))
- (terpri)
- (princ "(p ")
- (princ name)
- top (cond ((atom matrix) (go fin)))
- (setq next (car matrix))
- (setq matrix (cdr matrix))
- (setq lab nil)
- (terpri)
- (cond
- ((eq next '-)
- (princ " - ")
- (setq next (car matrix))
- (setq matrix (cdr matrix)))
- ((eq next '-->) (princ " "))
- ((and (eq next '!{) (atom (car matrix)))
- (princ " {")
- (setq lab (car matrix))
- (setq next (cadr matrix))
- (setq matrix (cdddr matrix)))
- ((eq next '!{)
- (princ " {")
- (setq lab (cadr matrix))
- (setq next (car matrix))
- (setq matrix (cdddr matrix)))
- (t (princ " ")))
- (ppline next)
- (cond (lab (princ " ") (princ lab) (princ '!})))
- (go top)
- fin (princ ")")))
-
- (de ppline (line)
- (prog ()
- (cond
- ((atom line) (princ line))
- (t (princ "(") (setq *ppline* line) (ppline2) (princ ")")))
- (return nil)))
-
- (de ppline2 ()
- (prog (needspace)
- (setq needspace nil)
- top (cond ((atom *ppline*) (return nil)))
- (and needspace (princ " "))
- (cond ((eq (car *ppline*) '!^) (ppattval)) (t (pponlyval)))
- (setq needspace t)
- (go top)))
-
- (de ppattval ()
- (prog (att val)
- (setq att (cadr *ppline*))
- (setq *ppline* (cddr *ppline*))
- (setq val (getval))
- (cond
- ((greaterp (iplus (posn) (flatc att) (flatc val)) 76)
- (terpri)
- (princ " ")))
- (princ '!^)
- (princ att)
- (!!mapc (function (lambda (z) (princ " ") (princ z))) val)))
-
- (de pponlyval ()
- (prog (val needspace)
- (setq val (getval))
- (setq needspace nil)
- (cond
- ((greaterp (iplus (posn) (flatc val)) 76)
- (setq needspace nil)
- (terpri)
- (princ " ")))
- top (cond ((atom val) (return nil)))
- (and needspace (princ " "))
- (setq needspace t)
- (princ (car val))
- (setq val (cdr val))
- (go top)))
-
- (de getval ()
- (prog (res v1)
- (setq v1 (car *ppline*))
- (setq *ppline* (cdr *ppline*))
- (cond
- ((memq v1 '(= <> < <= => > <=>))
- (setq res (cons v1 (getval))))
- ((eq v1 '!{) (setq res (cons v1 (getupto '!}))))
- ((eq v1 '<<) (setq res (cons v1 (getupto '>>))))
- ((eq v1 '!/)
- (setq res (list v1 (car *ppline*)))
- (setq *ppline* (cdr *ppline*)))
- (t (setq res (list v1))))
- (return res)))
-
- (de getupto (end)
- (prog (v)
- (cond ((atom *ppline*) (return nil)))
- (setq v (car *ppline*))
- (setq *ppline* (cdr *ppline*))
- (cond
- ((eq v end) (return (list v)))
- (t (return (cons v (getupto end)))) )))
-
-
- %%% backing up
-
- (de record-index-plus (k)
- (setq *record-index* (iplus k *record-index*))
- (cond
- ((lessp *record-index* 0)
- (setq *record-index* *max-record-index*))
- ((greaterp *record-index* *max-record-index*)
- (setq *record-index* 0))))
-
- % the following routine initializes the record. putting nil in the
- % first slot indicates that that the record does not go back further
- % than that. (when the system backs up, it writes nil over the used
- % records so that it will recognize which records it has used. thus
- % the system is set up anyway never to back over a nil.)
- (de initialize-record nil
- (setq *record-index* 0)
- (setq *recording* nil)
- (setq *max-record-index* 31)
- (putv *record-array* 0 nil))
-
- % *max-record-index* holds the maximum legal index for record-array
- % so it and the following must be changed at the same time
- (de begin-record (p data)
- (setq *recording* t)
- (setq *record* (list '=>refract p data)))
-
- (de end-record nil
- (cond
- (*recording*
- (setq *record*
- (cons *cycle-count* (cons *p-name* *record*)))
- (record-index-plus 1)
- (putv *record-array* *record-index* *record*)
- (setq *record* nil)
- (setq *recording* nil))))
-
- (de record-change (direct time elm)
- (cond
- (*recording*
- (setq *record*
- (cons direct (cons time (cons elm *record*)))) )))
-
- % to maintain refraction information, need keep only one piece of information:
- % need to record all unsuccessful attempts to delete things from the conflict
- % set. unsuccessful deletes are caused by attempting to delete refracted
- % instantiations. when backing up, have to avoid putting things back into the
- % conflict set if they were not deleted when running forward
- (de record-refract (rule data)
- (and
- *recording*
- (setq *record*
- (cons '<=refract (cons rule (cons data *record*)))) ))
-
- (de refracted (rule data)
- (prog (z)
- (cond ((null *refracts*) (return nil)))
- (setq z (cons rule data))
- (return (member z *refracts*))))
-
- (de back (k)
- (prog (r)
- l: (cond ((lessp k 1) (return nil)))
- (setq r (getv *record-array* *record-index*))
- (cond ((null r) (return "nothing more stored")))
- (putv *record-array* *record-index* nil)
- (record-index-plus (!!minus 1))
- (undo-record r)
- (setq k (isub1 k))
- (go l:)))
-
- (de undo-record (r)
- (prog (save act a b rate)
- %% *recording* must be off during back up
- (setq save *recording*)
- (setq *refracts* nil)
- (setq *recording* nil)
- (and *ptrace* (back-print (list 'undo: (car r) (cadr r))))
- (setq r (cddr r))
- top (cond ((atom r) (go fin)))
- (setq act (car r))
- (setq a (cadr r))
- (setq b (caddr r))
- (setq r (cdddr r))
- (and *wtrace* (back-print (list 'undo: act a)))
- (cond
- ((eq act '<=wm) (add-to-wm b a))
- ((eq act '=>wm) (remove-from-wm b))
- ((eq act '<=refract)
- (setq *refracts* (cons (cons a b) *refracts*)))
- ((and (eq act '=>refract) (still-present b))
- (setq *refracts* (delete (cons a b) *refracts*))
- (setq rate (rating-part (get a 'topnode)))
- (removecs a b)
- (insertcs a b rate))
- (t (!%warn "back: cannot undo action" (list act a))))
- (go top)
- fin (setq *recording* save)
- (setq *refracts* nil)
- (return nil)))
-
- % still-present makes sure that the user has not deleted something
- % from wm which occurs in the instantiation about to be restored; it
- % makes the check by determining whether each wme still has a time tag.
- (de still-present (data)
- (prog nil
- l: (cond
- ((atom data) (return t))
- ((creation-time (car data)) (setq data (cdr data)) (go l:))
- (t (return nil)))) )
-
- (de back-print (x)
- (prog (port)
- (setq port (trace-file))
- (terpri port)
- (print x port)))
-
- %%% Functions to show how close rules are to firing
-
- (df matches rule-list
- (!!mapc (function matches2) rule-list)
- (terpri))
-
- (de matches2 (p)
- (cond
- ((atom p)
- (terpri)
- (terpri)
- (princ p)
- (matches3 (get p 'backpointers) 2 (ncons 1)))) )
-
- (de matches3 (nodes ce part)
- (cond
- ((not (null nodes))
- (terpri)
- (princ " ** matches for ")
- (princ part)
- (princ " ** ")
- (!!mapc (function write-elms) (find-left-mem (car nodes)))
- (terpri)
- (princ " ** matches for ")
- (princ (ncons ce))
- (princ " ** ")
- (!!mapc (function write-elms) (find-right-mem (car nodes)))
- (matches3 (cdr nodes) (iadd1 ce) (cons ce part)))) )
-
- (de write-elms (wme-or-count)
- (cond
- ((pairp wme-or-count)
- (terpri)
- (!!mapc (function write-elms2) wme-or-count))))
-
- (de write-elms2 (x) (princ " ") (princ (creation-time x)))
-
- (de find-left-mem (node)
- (cond
- ((eq (car node) '&and) (memory-part (caddr node)))
- (t (car (caddr node)))) )
-
- (de find-right-mem (node) (memory-part (cadddr node)))
-
- %%% Check the RHSs of productions
-
- (de check-rhs (rhs) (!!mapc (function check-action) rhs))
-
- (de check-action (x)
- (prog (a)
- (cond ((atom x) (!%warn "atomic action" x) (return nil)))
- (setq a (setq *action-type* (car x)))
- (cond
- ((eq a 'bind) (check-bind x))
- ((eq a 'cbind) (check-cbind x))
- ((eq a 'make) (check-make x))
- ((eq a 'modify) (check-modify x))
- ((eq a 'remove) (check-remove x))
- ((eq a 'write) (check-write x))
- ((eq a 'call) (check-call x))
- ((eq a 'halt) (check-halt x))
- ((eq a 'openfile) (check-openfile x))
- ((eq a 'closefile) (check-closefile x))
- ((eq a 'default) (check-default x))
- ((eq a 'build) (check-build x))
- (t (!%warn "undefined rhs action" a)))) )
-
- (de check-build (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-build-collect (cdr z)))
-
- (de check-build-collect (args)
- (prog (r)
- top (cond ((null args) (return nil)))
- (setq r (car args))
- (setq args (cdr args))
- (cond
- ((pairp r) (check-build-collect r))
- ((eq r '!!)
- (and (null args) (!%warn "nothing to evaluate" r))
- (check-rhs-value (car args))
- (setq args (cdr args))))
- (go top)))
-
- (de check-remove (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (!!mapc (function check-rhs-ce-var) (cdr z)))
-
- (de check-make (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-change& (cdr z)))
-
- (de check-openfile (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-change& (cdr z)))
-
- (de check-closefile (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-change& (cdr z)))
-
- (de check-default (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-change& (cdr z)))
-
- (de check-modify (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-rhs-ce-var (cadr z))
- (and (null (cddr z)) (!%warn "no changes to make" z))
- (check-change& (cddr z)))
-
- (de check-write (z)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (check-change& (cdr z)))
-
- (de check-call (z)
- (prog (f)
- (and (null (cdr z)) (!%warn "needs arguments" z))
- (setq f (cadr z))
- (and
- (variablep f)
- (!%warn "function name must be a constant" z))
- (or
- (idp f)
- (!%warn "function name must be a symbolic atom" f))
- (or
- (externalp f)
- (!%warn "function name not declared external" f))
- (check-change& (cddr z))))
-
- (de check-halt (z)
- (or (null (cdr z)) (!%warn "does not take arguments" z)))
-
- (de check-cbind (z)
- (prog (v)
- (or (eq (length z) 2) (!%warn "takes only one argument" z))
- (setq v (cadr z))
- (or (variablep v) (!%warn "takes variable as argument" z))
- (note-ce-variable v)))
-
- (de check-bind (z)
- (prog (v)
- (or (igreaterp (length z) 1) (!%warn "needs arguments" z))
- (setq v (cadr z))
- (or (variablep v) (!%warn "takes variable as argument" z))
- (note-variable v)
- (check-change& (cddr z))))
-
- (de check-change& (z)
- (prog (r tab-flag)
- (setq tab-flag nil)
- la (cond ((atom z) (return nil)))
- (setq r (car z))
- (setq z (cdr z))
- (cond
- ((eq r '!^)
- (and
- tab-flag
- (!%warn "no value before this tab" (car z)))
- (setq tab-flag t)
- (check-tab-index (car z))
- (setq z (cdr z)))
- ((eq r '!/) (setq tab-flag nil) (setq z (cdr z)))
- (t (setq tab-flag nil) (check-rhs-value r)))
- (go la)))
-
- (de check-rhs-ce-var (v)
- (cond
- ((and (not (numberp v)) (not (ce-bound? v)))
- (!%warn "unbound element variable" v))
- ((and (numberp v) (or (lessp v 1) (greaterp v *ce-count*)))
- (!%warn "numeric element designator out of bounds" v))))
-
- (de check-rhs-value (x)
- (cond ((pairp x) (check-rhs-function x)) (t (check-rhs-atomic x))))
-
- (de check-rhs-atomic (x)
- (and
- (variablep x)
- (not (bound? x))
- (!%warn "unbound variable" x)))
-
- (de check-rhs-function (x)
- (prog (a)
- (setq a (car x))
- (cond
- ((eq a 'compute) (check-compute x))
- ((eq a 'arith) (check-compute x))
- ((eq a 'substr) (check-substr x))
- ((eq a 'accept) (check-accept x))
- ((eq a 'acceptline) (check-acceptline x))
- ((eq a 'crlf) (check-crlf x))
- ((eq a 'genatom) (check-genatom x))
- ((eq a 'litval) (check-litval x))
- ((eq a 'tabto) (check-tabto x))
- ((eq a 'rjust) (check-rjust x))
- ((not (externalp a))
- (!%warn "rhs function not declared external" a)))) )
-
- (de check-litval (x)
- (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
- (check-rhs-atomic (cadr x)))
-
- (de check-accept (x)
- (cond
- ((eq (length x) 1) nil)
- ((eq (length x) 2) (check-rhs-atomic (cadr x)))
- (t (!%warn "too many arguments" x))))
-
- (de check-acceptline (x)
- (!!mapc (function check-rhs-atomic) (cdr x)))
-
- (de check-crlf (x) (check-0-args x))
-
- (de check-genatom (x) (check-0-args x))
-
- (de check-tabto (x)
- (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
- (check-print-control (cadr x)))
-
- (de check-rjust (x)
- (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
- (check-print-control (cadr x)))
-
- (de check-0-args (x)
- (or (eq (length x) 1) (!%warn "should not have arguments" x)))
-
- (de check-substr (x)
- (or (eq (length x) 4) (!%warn "wrong number of arguments" x))
- (check-rhs-ce-var (cadr x))
- (check-substr-index (caddr x))
- (check-last-substr-index (cadddr x)))
-
- (de check-compute (x) (check-arithmetic (cdr x)))
-
- (de check-arithmetic (l)
- (cond
- ((atom l) (!%warn "syntax error in arithmetic expression" l))
- ((atom (cdr l)) (check-term (car l)))
- ((not (memq (cadr l) '(+ - * !/)))
- (!%warn "unknown operator" l))
- (t (check-term (car l)) (check-arithmetic (cddr l)))) )
-
- (de check-term (x)
- (cond ((pairp x) (check-arithmetic x)) (t (check-rhs-atomic x))))
-
- (de check-last-substr-index (x)
- (or (eq x 'inf) (check-substr-index x)))
-
- (de check-substr-index (x)
- (prog (v)
- (cond ((bound? x) (return x)))
- (setq v ($litbind x))
- (cond
- ((not (numberp v))
- (!%warn "unbound symbol used as index in substr" x))
- ((or (lessp v 1) (greaterp v 127))
- (!%warn "index out of bounds in tab" x)))) )
-
- (de check-print-control (x)
- (prog ()
- (cond ((bound? x) (return x)))
- (cond
- ((or (not (numberp x)) (lessp x 1) (greaterp x 127))
- (!%warn "illegal value for printer control" x)))) )
-
- (de check-tab-index (x)
- (prog (v)
- (cond ((bound? x) (return x)))
- (setq v ($litbind x))
- (cond
- ((not (numberp v))
- (!%warn "unbound symbol occurs after ^" x))
- ((or (lessp v 1) (greaterp v 127))
- (!%warn "index out of bounds after ^" x)))) )
-
- (de note-variable (var)
- (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
-
- (de bound? (var) (or (memq var *rhs-bound-vars*) (var-dope var)))
-
- (de note-ce-variable (ce-var)
- (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
-
- (de ce-bound? (ce-var)
- (or (memq ce-var *rhs-bound-ce-vars*) (ce-var-dope ce-var)))
-
- %%% Top level routines
-
- (de process-changes (adds dels)
- (prog (x)
- process-deletes
- (cond ((atom dels) (go process-adds)))
- (setq x (car dels))
- (setq dels (cdr dels))
- (remove-from-wm x)
- (go process-deletes)
- process-adds
- (cond ((atom adds) (return nil)))
- (setq x (car adds))
- (setq adds (cdr adds))
- (add-to-wm x nil)
- (go process-adds)))
-
- (de main nil
- (prog (instance r)
- (setq *halt-flag* nil)
- (setq *break-flag* nil)
- (setq instance nil)
- dil (setq *phase* 'conflict-resolution)
- (cond
- (*halt-flag* (setq r "end -- explicit halt") (go finis))
- ((izerop *remaining-cycles*)
- (setq r '***break***)
- (setq *break-flag* t)
- (go finis))
- (*break-flag* (setq r '***break***) (go finis)))
- (setq *remaining-cycles* (isub1 *remaining-cycles*))
- (setq instance (conflict-resolution))
- (cond
- ((not instance)
- (setq r "end -- no production true")
- (go finis)))
- (setq *phase* (car instance))
- (accum-stats)
- (eval-rhs (car instance) (cdr instance))
- (check-limits)
- (and (broken (car instance)) (setq *break-flag* t))
- (go dil)
- finis (setq *p-name* nil)
- (return r)))
-
- (de do-continue (wmi)
- (cond
- (*critical*
- (terpri)
- (princ "warning: network may be inconsistent")))
- (process-changes wmi nil)
- (print-times (main)))
-
- (de accum-stats nil
- (setq *cycle-count* (iadd1 *cycle-count*))
- (setq *total-token* (iplus *total-token* *current-token*))
- (cond
- ((igreaterp *current-token* *max-token*)
- (setq *max-token* *current-token*)))
- (setq *total-wm* (iplus *total-wm* *current-wm*))
- (cond
- ((greaterp *current-wm* *max-wm*)
- (setq *max-wm* *current-wm*))))
-
- (de print-times (mess)
- (prog (cc ac)
- (cond (*break-flag* (terpri) (return mess)))
- (setq cc (plus (float *cycle-count*) 10.0e-20))
- (setq ac (plus (float *action-count*) 1.0e-20))
- (terpri)
- (princ mess)
- (pm-size)
- (printlinec
- (list
- *cycle-count*
- 'firings
- (list *action-count* 'rhs 'actions)))
- (terpri)
- (printlinec
- (list
- (round (quotient (float *total-wm*) cc))
- 'mean
- 'working
- 'memory
- 'size
- (list *max-wm* 'maximum)))
- (terpri)
- (printlinec
- (list
- (round (quotient (float *total-cs*) cc))
- 'mean
- 'conflict
- 'set
- 'size
- (list *max-cs* 'maximum)))
- (terpri)
- (printlinec
- (list
- (round (quotient (float *total-token*) cc))
- 'mean
- 'token
- 'memory
- 'size
- (list *max-token* 'maximum)))
- (terpri)))
-
- (de pm-size nil
- (terpri)
- (printlinec
- (list
- *pcount*
- 'productions
- (list *real-cnt* '!/ *virtual-cnt* 'nodes)))
- (terpri))
-
- (de check-limits nil
- (cond
- ((igreaterp (length *conflict-set*) *limit-cs*)
- (terpri)
- (terpri)
- (printlinec
- (list
- "conflict set size exceeded the limit of"
- *limit-cs*
- "after"
- *p-name*))
- (setq *halt-flag* t)))
- (cond
- ((igreaterp *current-token* *limit-token*)
- (terpri)
- (terpri)
- (printlinec
- (list
- "token memory size exceeded the limit of"
- *limit-token*
- "after"
- *p-name*))
- (setq *halt-flag* t))))
-
- (de top-level-remove (z)
- (cond
- ((equal z '(*)) (process-changes nil (get-wm nil)))
- (t (process-changes nil (get-wm z)))) )
-
- (df excise z (!!mapc (function excise-p) z))
-
- (df run z
- (cond
- ((atom z) (setq *remaining-cycles* 1000000) (do-continue nil))
- ((and (atom (cdr z)) (numberp (car z)) (greaterp (car z) 0))
- (setq *remaining-cycles* (car z))
- (do-continue nil))
- (t 'what?)))
-
- (df strategy z
- (cond
- ((atom z) *strategy*)
- ((equal z '(lex)) (setq *strategy* 'lex))
- ((equal z '(mea)) (setq *strategy* 'mea))
- (t 'what?)))
-
- (df cs z (cond ((atom z) (conflict-set)) (t 'what?)))
-
- (df watch z
- (cond
- ((equal z '(0)) (setq *wtrace* nil) (setq *ptrace* nil) 0)
- ((equal z '(1)) (setq *wtrace* nil) (setq *ptrace* t) 1)
- ((equal z '(2)) (setq *wtrace* t) (setq *ptrace* t) 2)
- ((equal z '(3))
- (setq *wtrace* t)
- (setq *ptrace* t)
- '(2 -- conflict set trace not supported))
- ((and (atom z) (null *ptrace*)) 0)
- ((and (atom z) (null *wtrace*)) 1)
- ((atom z) 2)
- (t 'what?)))
-
- (df external z (catch !!error!! (external2 z)))
-
- (de external2 (z) (!!mapc (function external3) z))
-
- (de external3 (x)
- (cond
- ((idp x) (putprop x t 'external-routine))
- (t (!%error "not a legal function name" x))))
-
- (de externalp (x)
- (cond
- ((idp x) (get x 'external-routine))
- (t (!%warn "not a legal function name" x) nil)))
-
- (df pbreak z
- (cond
- ((atom z) (terpri) *brkpts*)
- (t (!!mapc (function pbreak2) z) nil)))
-
- (de pbreak2 (rule)
- (cond
- ((not (idp rule)) (!%warn "illegal name" rule))
- ((not (get rule 'topnode)) (!%warn "not a production" rule))
- ((memq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
- (t (setq *brkpts* (cons rule *brkpts*)))) )
-
- (de rematm (atm list)
- (cond
- ((atom list) list)
- ((eq atm (car list)) (rematm atm (cdr list)))
- (t (cons (car list) (rematm atm (cdr list)))) ))
-
- (de broken (rule) (memq rule *brkpts*))
-
- (i-g-v)
-
- (setsyntax '!{ 'read!-macro nil)
- (setsyntax "{}" 'letter t)
- (setsyntax "{}" 'break-character nil)
- (car!-nil!-legal t)
-
-
- fin
-
-